{-# LANGUAGE OverloadedStrings #-}

module Text.Megaparsec.ErrorSpec (spec) where

import Control.Exception (Exception (..))
import Data.Functor.Identity
import Data.List (isInfixOf, isSuffixOf, sort)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Set as E
import Data.Void
import Test.Hspec
import Test.Hspec.Megaparsec
import Test.Hspec.Megaparsec.AdHoc ()
import Test.QuickCheck
import Text.Megaparsec

spec :: Spec
spec = do
  describe "Semigroup instance of ParseError" $
    it "associativity" $
      property $ \x y z ->
        (x <> y) <> z === (x <> (y <> z) :: PE)

  describe "Monoid instance of ParseError" $ do
    it "left identity" $
      property $ \x ->
        mempty <> x === (x :: PE)
    it "right identity" $
      property $ \x ->
        x <> mempty === (x :: PE)
    it "associativity" $
      property $ \x y z ->
        (x <> y) <> z === (x <> (y <> z) :: PE)

  describe "error merging with (<>)" $ do
    it "selects greater offset" $
      property $ \x y ->
        errorOffset (x <> y :: PE) === max (errorOffset x) (errorOffset y)
    context "when combining two trivial parse errors at the same position" $
      it "merges their unexpected and expected items" $
        do
          let n Nothing Nothing = Nothing
              n (Just x) Nothing = Just x
              n Nothing (Just y) = Just y
              n (Just x) (Just y) = Just (max x y)
          property $ \pos us0 ps0 us1 ps1 ->
            TrivialError pos us0 ps0 <> TrivialError pos us1 ps1
              `shouldBe` (TrivialError pos (n us0 us1) (E.union ps0 ps1) :: PE)
    context "when combining two fancy parse errors at the same position" $
      it "merges their custom items" $
        property $ \pos xs0 xs1 ->
          FancyError pos xs0 <> FancyError pos xs1
            `shouldBe` (FancyError pos (E.union xs0 xs1) :: PE)
    context "when combining trivial error with fancy error" $ do
      it "fancy has precedence (left)" $
        property $ \pos us ps xs ->
          FancyError pos xs <> TrivialError pos us ps
            `shouldBe` (FancyError pos xs :: PE)
      it "fancy has precedence (right)" $
        property $ \pos us ps xs ->
          TrivialError pos us ps <> FancyError pos xs
            `shouldBe` (FancyError pos xs :: PE)

  -- NOTE 'errorOffset' and 'setErrorOffset' are trivial.

  describe "attachSourcePos" $
    it "attaches the positions correctly" $
      property $ \xs' s -> do
        let xs = sort $ getSmall . getPositive <$> xs'
            pst = initialPosState (s :: String)
            pst' =
              if null xs
                then pst
                else reachOffsetNoLine (last xs) pst
            rs = f <$> xs
            f x = (x, pstateSourcePos (reachOffsetNoLine x pst))
        attachSourcePos id (xs :: [Int]) pst `shouldBe` (rs, pst')

  describe "errorBundlePretty" $ do
    it "shows empty line correctly" $ do
      let s = "" :: String
      mkBundlePE s (mempty :: PE)
        `shouldBe` "1:1:\n  |\n1 | <empty line>\n  | ^\nunknown parse error\n"
    it "shows position on first line correctly" $ do
      let s = "abc" :: String
          pe = err 1 (utok 'b' <> etok 'd') :: PE
      mkBundlePE s pe
        `shouldBe` "1:2:\n  |\n1 | abc\n  |  ^\nunexpected 'b'\nexpecting 'd'\n"
    it "skips to second line correctly" $ do
      let s = "one\ntwo\n" :: String
          pe = err 4 (utok 't' <> etok 'x') :: PE
      mkBundlePE s pe
        `shouldBe` "2:1:\n  |\n2 | two\n  | ^\nunexpected 't'\nexpecting 'x'\n"
    it "shows position on 1000 line correctly" $ do
      let s = replicate 999 '\n' ++ "abc"
          pe = err 999 (utok 'a' <> etok 'd') :: PE
      mkBundlePE s pe
        `shouldBe` "1000:1:\n     |\n1000 | abc\n     | ^\nunexpected 'a'\nexpecting 'd'\n"
    it "shows offending line in the presence of tabs correctly" $ do
      let s = "\tsomething" :: String
          pe = err 1 (utok 's' <> etok 'x') :: PE
      mkBundlePE s pe
        `shouldBe` "1:9:\n  |\n1 |         something\n  |         ^\nunexpected 's'\nexpecting 'x'\n"
    it "uses continuous highlighting properly (trivial)" $ do
      let s = "\tfoobar" :: String
          pe = err 1 (utoks "foo" <> utoks "rar") :: PE
      mkBundlePE s pe
        `shouldBe` "1:9:\n  |\n1 |         foobar\n  |         ^^^\nunexpected \"rar\"\n"
    it "uses continuous highlighting properly (fancy)" $ do
      let s = "\tfoobar" :: String
          pe =
            errFancy
              1
              (fancy $ ErrorCustom (CustomErr 5)) ::
              ParseError String CustomErr
      mkBundlePE s pe
        `shouldBe` "1:9:\n  |\n1 |         foobar\n  |         ^^^^^\ncustom thing\n"
    it "adjusts continuous highlighting so it doesn't get too long" $ do
      let s = "foobar\n" :: String
          pe = err 4 (utoks "foobar" <> etoks "foobar") :: PE
      mkBundlePE s pe
        `shouldBe` "1:5:\n  |\n1 | foobar\n  |     ^^^\nunexpected \"foobar\"\nexpecting \"foobar\"\n"
    context "stream of insufficient size is provided in the bundle" $
      it "handles the situation reasonably" $
        do
          let s = "" :: String
              pe = err 3 (ueof <> etok 'x') :: PE
          mkBundlePE s pe
            `shouldBe` "1:1:\n  |\n1 | <empty line>\n  | ^\nunexpected end of input\nexpecting 'x'\n"
    context "starting column in bundle is greater than 1" $ do
      context "and less than parse error column" $
        it "is rendered correctly" $
          do
            let s = "foo" :: String
                pe = err 5 (utok 'o' <> etok 'x') :: PE
                bundle =
                  ParseErrorBundle
                    { bundleErrors = pe :| [],
                      bundlePosState =
                        PosState
                          { pstateInput = s,
                            pstateOffset = 4,
                            pstateSourcePos = SourcePos "" pos1 (mkPos 5),
                            pstateTabWidth = defaultTabWidth,
                            pstateLinePrefix = ""
                          }
                    }
            errorBundlePretty bundle
              `shouldBe` "1:6:\n  |\n1 | foo\n  | \nunexpected 'o'\nexpecting 'x'\n"
      context "and greater than parse error column" $
        it "is rendered correctly" $
          do
            let s = "foo" :: String
                pe = err 5 (utok 'o' <> etok 'x') :: PE
                bundle =
                  ParseErrorBundle
                    { bundleErrors = pe :| [],
                      bundlePosState =
                        PosState
                          { pstateInput = s,
                            pstateOffset = 9,
                            pstateSourcePos = SourcePos "" pos1 (mkPos 10),
                            pstateTabWidth = defaultTabWidth,
                            pstateLinePrefix = ""
                          }
                    }
            errorBundlePretty bundle
              `shouldBe` "1:10:\n  |\n1 | foo\n  | \nunexpected 'o'\nexpecting 'x'\n"
    it "takes tab width into account correctly" $
      property $ \w' i' -> do
        let w = unPos w'
            i = unPos i' `rem` (w * 2)
            as = replicate i 'a'
            s = "\t" ++ as ++ "\tb" :: String
            pe = err (2 + i) (utok 'b' <> etok 'x') :: PE
            bundle =
              ParseErrorBundle
                { bundleErrors = pe :| [],
                  bundlePosState =
                    PosState
                      { pstateInput = s,
                        pstateOffset = 0,
                        pstateSourcePos = initialPos "",
                        pstateTabWidth = w',
                        pstateLinePrefix = ""
                      }
                }
            secondTabApparentWidth = w - (i `rem` w)
            errColumn = w + i + secondTabApparentWidth
        errorBundlePretty bundle
          `shouldBe` ( "1:"
                         ++ show (errColumn + 1)
                         ++ ":\n  |\n1 | "
                         ++ replicate w ' '
                         ++ as
                         ++ replicate secondTabApparentWidth ' '
                         ++ "b"
                         ++ "\n  | "
                         ++ replicate errColumn ' '
                         ++ "^\nunexpected 'b'\nexpecting 'x'\n"
                     )
    context "in the presence of wide characters" $ do
      it "calculates column positions correctly" $ do
        let s = "구구 이면" :: String
            pe = err 2 (ulabel "space" <> etok '이') :: PE
            bundle =
              ParseErrorBundle
                { bundleErrors = pe :| [],
                  bundlePosState =
                    PosState
                      { pstateInput = s,
                        pstateOffset = 0,
                        pstateSourcePos = initialPos "",
                        pstateTabWidth = defaultTabWidth,
                        pstateLinePrefix = ""
                      }
                }
        errorBundlePretty bundle
          `shouldBe` "1:5:\n  |\n1 | 구구 이면\n  |     ^\nunexpected space\nexpecting '이'\n"
      it "uses continuous highlighting" $ do
        let s = "구구 이면" :: String
            pe = err 3 (utok '이' <> etok '구') :: PE
            bundle =
              ParseErrorBundle
                { bundleErrors = pe :| [],
                  bundlePosState =
                    PosState
                      { pstateInput = s,
                        pstateOffset = 0,
                        pstateSourcePos = initialPos "",
                        pstateTabWidth = defaultTabWidth,
                        pstateLinePrefix = ""
                      }
                }
        errorBundlePretty bundle
          `shouldBe` "1:6:\n  |\n1 | 구구 이면\n  |      ^^\nunexpected '이'\nexpecting '구'\n"
    it "displays multi-error bundle correctly" $ do
      let s = "something\ngood\n" :: String
          pe0 = err 2 (utok 'm' <> etok 'x') :: PE
          pe1 = err 10 (utok 'g' <> etok 'y') :: PE
          bundle =
            ParseErrorBundle
              { bundleErrors = pe0 :| [pe1],
                bundlePosState =
                  PosState
                    { pstateInput = s,
                      pstateOffset = 0,
                      pstateSourcePos = initialPos "",
                      pstateTabWidth = defaultTabWidth,
                      pstateLinePrefix = ""
                    }
              }
      errorBundlePretty bundle
        `shouldBe` "1:3:\n  |\n1 | something\n  |   ^\nunexpected 'm'\nexpecting 'x'\n\n2:1:\n  |\n2 | good\n  | ^\nunexpected 'g'\nexpecting 'y'\n"

  describe "parseErrorPretty" $ do
    it "shows unknown ParseError correctly" $
      parseErrorPretty (mempty :: PE) `shouldBe` "offset=0:\nunknown parse error\n"
    it "result always ends with a newline" $
      property $ \x ->
        parseErrorPretty (x :: PE) `shouldSatisfy` ("\n" `isSuffixOf`)
    it "result contains representation of offset" $
      property (contains (Identity . errorOffset) show)
    it "result contains unexpected/expected items" $ do
      let e = err 0 (utoks "foo" <> etoks "bar" <> etoks "baz") :: PE
      parseErrorPretty e `shouldBe` "offset=0:\nunexpected \"foo\"\nexpecting \"bar\" or \"baz\"\n"
    it "result contains representation of custom items" $ do
      let e = errFancy 0 (fancy (ErrorFail "Ooops!")) :: PE
      parseErrorPretty e `shouldBe` "offset=0:\nOoops!\n"
    it "several fancy errors look not so bad" $ do
      let pe :: PE
          pe =
            errFancy 0 $
              mempty <> fancy (ErrorFail "foo") <> fancy (ErrorFail "bar")
      parseErrorPretty pe `shouldBe` "offset=0:\nbar\nfoo\n"

  describe "parseErrorTextPretty" $ do
    it "shows trivial unknown ParseError correctly" $
      parseErrorTextPretty (mempty :: PE)
        `shouldBe` "unknown parse error\n"
    it "shows fancy unknown ParseError correctly" $
      parseErrorTextPretty (FancyError 0 E.empty :: PE)
        `shouldBe` "unknown fancy parse error\n"
    it "result always ends with a newline" $
      property $ \x ->
        parseErrorTextPretty (x :: PE)
          `shouldSatisfy` ("\n" `isSuffixOf`)

  describe "displayException" $
    it "produces the same result as parseErrorPretty" $
      property $ \x ->
        displayException x `shouldBe` parseErrorPretty (x :: PE)

----------------------------------------------------------------------------
-- Helpers

-- | A custom error component to test continuous highlighting for custom
-- components.
newtype CustomErr = CustomErr Int
  deriving (Eq, Ord, Show)

instance ShowErrorComponent CustomErr where
  showErrorComponent _ = "custom thing"
  errorComponentLen (CustomErr n) = n

type PE = ParseError String Void

contains :: (Foldable t) => (PE -> t a) -> (a -> String) -> PE -> Property
contains g r e = property (all f (g e))
  where
    rendered = parseErrorPretty e
    f x = r x `isInfixOf` rendered

mkBundlePE ::
  ( VisualStream s,
    TraversableStream s,
    ShowErrorComponent e
  ) =>
  s ->
  ParseError s e ->
  String
mkBundlePE s e =
  errorBundlePretty $
    ParseErrorBundle
      { bundleErrors = e :| [],
        bundlePosState =
          PosState
            { pstateInput = s,
              pstateOffset = 0,
              pstateSourcePos = initialPos "",
              pstateTabWidth = defaultTabWidth,
              pstateLinePrefix = ""
            }
      }
